home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
REDUCE.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
13KB
|
518 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
/* This file contains various functions needed for reduce actions */
#include "hdr.h"
#include "ada.h"
#include "adared.h"
#include "setp.h"
#include "smiscp.h"
#include "prsutilp.h"
#include "errsp.h"
#include "adalexp.h"
#include "pspansp.h"
#include "reducep.h"
static void pragma_warning(Node);
static int in_label_set(Node, Tuple);
static int is_pragma(int);
void free_everything(Node n)
{
}
struct two_pool *initlist(Node node) /*;initlist*/
{
/* Allocate a single list structure (struct two_pool), set its data to
* be a pointer to the node given, and set its link field to point
* to itself, since tree node lists are circular.
*/
struct two_pool *tmp;
tmp = TALLOC();
tmp->val.node = node;
tmp->link = tmp;
return(tmp);
}
void append(Node orignode, Node node) /*;append*/
{
/* Append node to list within orignode */
if (N_LIST(orignode) == (Tuple)0)
N_LIST(orignode) = tup_new1((char *)node);
else
N_LIST(orignode) = tup_with(N_LIST(orignode), (char *)node);
}
void prepend(Node node, Node orignode) /*;prepend*/
{
/* Prepends list within orignode with node */
Tuple beglist = tup_new1((char *)node);
if (N_LIST(orignode) == (Tuple)0)
N_LIST(orignode) = beglist;
else
N_LIST(orignode) = tup_add(beglist, N_LIST(orignode));
}
Node binary_operator(Node optr, Node expr1, Node expr2) /*;binary_operator*/
{
/* Set up the AST node for a binary operator. */
Node node, arg_list_node;
node = node_new(as_op);
arg_list_node = node_new(as_list);
N_LIST(arg_list_node) = tup_new2((char *)expr1, (char *)expr2);
insert_2child(node, optr, arg_list_node);
return(node);
}
Node unary_operator(Node optr, Node expr) /*;unary_operator*/
{
/* Set up the AST node for a unary operator. */
Node node, arg_list_node;
node = node_new(as_un_op);
arg_list_node = node_new(as_list);
N_LIST(arg_list_node) = tup_new1((char *)expr);
insert_2child(node, optr, arg_list_node);
return(node);
}
int check_expanded_name(Node name) /*;check_expanded_name*/
{
/* Make sure an expanded name node is valid. */
#define sub_expanded_name (N_AST1(name))
return((N_KIND(name) == as_selector) ?
check_expanded_name(sub_expanded_name) : (N_KIND(name)== as_simple_name));
#undef sub_expanded_name
}
void check_discrete_range(Node discrete_range) /*;check_discrete_range*/
{
/* Check whether a discrete range node is valid. */
switch (N_KIND(discrete_range))
{
case as_range_expression :
#define name (N_AST1(discrete_range))
if (!check_expanded_name(name))
syntax_err(SPAN(discrete_range),
"Invalid discrete_range specification");
else
N_KIND(discrete_range) = as_name;
break;
#undef name
case as_range_attribute :
case as_subtype :
break;
default :
syntax_err(SPAN(discrete_range),
"Invalid discrete_range specification");
}
}
static void pragma_warning(Node pragma_node) /*;pragma_warning*/
{
/* Give a warning that a pragma is ignored. */
char msg[MAXLINE + 30];
#define id (N_AST1(pragma_node))
sprintf(msg,"Pragma %s is ignored", namelist(N_ID(id)));
prs_warning(SPAN(pragma_node),msg);
#undef id
}
void pragmalist_warning(Node list_node) /*;pragmalist_warning*/
{
/* For all nodes in the list of list_node give a warning the the pragma
* is invalid.
*/
Node tmp_node;
Fortup ft1;
if (N_LIST(list_node) != (Tuple)0) {
FORTUP(tmp_node = (Node), N_LIST(list_node), ft1);
pragma_warning(tmp_node);
ENDFORTUP(ft1);
}
}
void check_pragmas(Node pragma_node, int (*allowed_test)(int))
/*;check_pragmas*/
{
/* Check that a pragma is valid. */
Tuple new_list = tup_new(0);
Node tmp_node;
Fortup ft1;
int id;
if (N_LIST(pragma_node) != (Tuple)0) {
FORTUP(tmp_node = (Node), N_LIST(pragma_node), ft1);
id = N_ID(N_AST1(tmp_node));
if (is_pragma(id) && (*allowed_test)(id - MIN_PRAGMA)) {
if (strcmp(namelist(id),"PRIORITY")
&& strcmp(namelist(id),"ELABORATE")
&& strcmp(namelist(id),"INTERFACE")) {
pragma_warning(tmp_node);
}
else
new_list = tup_with(new_list, (char *)tmp_node);
}
else if (is_pragma(id) && ispredef_pragma[id - MIN_PRAGMA]) {
char msg[200];
sprintf(msg,"Pragma %s is not valid in this context",
namelist(id));
prs_warning(SPAN(tmp_node),msg);
}
else if (!(is_pragma(id) && isimpldef_pragma[id - MIN_PRAGMA])
&& strcmp(namelist(id),"OPTIMIZE")) {
pragma_warning(tmp_node);
}
else
new_list = tup_with(new_list, (char *)tmp_node);
ENDFORTUP(ft1);
N_LIST(pragma_node) = new_list;
}
}
int isoverloadable_op(char *str) /*;isoverloadable_op*/
{
/* Check whether a string represnts an overloadable operator by
* comparing against all overloadable operators.
*/
char tmp[MAXLINE + 1];
int i;
strcpy(tmp, str);
convtolower(tmp);
for (i = 0; i < NUMOVERLOADOPS; i++)
if (!strcmp(tmp, overloadable_operators[i]))
return(1);
return(0);
}
/* The following functions are for passing to check_pragmas */
int immediate_decl_pragmas(int p) /*;immediate_decl_pragmas*/
{
return(isimmediate_decl_pragma[p]);
}
int compilation_pragmas(int p) /*;compilation_pragmas*/
{
return(iscompilation_pragma[p]);
}
int after_libunit_pragmas(int p) /*;after_libunit_pragmas*/
{
return(isafter_libunit_pragma[p]);
}
int task_pragmas(int p) /*;task_pragmas*/
{
return(istask_pragma[p]);
}
int task_repr_pragmas(int p) /*;task_repr_pragmas*/
{
return(istask_pragma[p] || isrepr_pragma[p]);
}
int context_pragmas(int p) /*;context_pragmas*/
{
return(iscontext_pragma[p]);
}
int null_pragmas(int i) /*;null_pragmas*/
{
return(i = 0);
}
void check_choices(Node alt_node, char *source) /*;check_choices*/
{
Tuple choice_list, others_indices = tup_new(0);
Node tmp_node, tmp_node2, last_alt = (Node) 0;
Fortup ft1, ft2;
int choice_flag = 0;
FORTUP(tmp_node = (Node), N_LIST(alt_node), ft1);
if (N_KIND(tmp_node) != as_pragma) {
choice_list = N_LIST(N_AST1(tmp_node));
if (tup_size(choice_list) > 1) {
FORTUP(tmp_node2 = (Node), choice_list, ft2);
if (N_KIND(tmp_node2) == as_others
|| N_KIND(tmp_node2) == as_others_choice) {
char msg[90];
sprintf(msg,"The choice OTHERS must appear alone in %s",
source);
syntax_err(SPAN(tmp_node2),msg);
choice_flag = 1;
break;
}
ENDFORTUP(ft2);
}
if (!choice_flag) {
if (N_KIND((Node)choice_list[1]) == as_others
|| N_KIND((Node)choice_list[1]) == as_others_choice)
others_indices = tup_with(others_indices, (char *)tmp_node);
}
else
choice_flag = 0;
last_alt = tmp_node;
}
ENDFORTUP(ft1);
FORTUP(tmp_node = (Node), others_indices, ft1); {
Node choice;
char msg[90];
if (tmp_node == last_alt)
continue;
choice = (Node)N_LIST(N_AST1(tmp_node))[1];
sprintf(msg,"The choice OTHERS must appear last in %s",source);
syntax_err(SPAN(choice),msg);
} ENDFORTUP(ft1);
/*
if (others_indices != (struct two_pool *)0 )
TFREE(others_indices->link,others_indices);
*/
}
Tuple remove_duplicate_labels(Tuple label_list)
/*;remove_duplicate_labels*/
{
Tuple new_label_list = tup_new(0), label_id_set = tup_new(0);
Fortup ft1, ft2;
Node tmp_node, tmp_node2, node, label;
FORTUP(tmp_node = (Node), label_list, ft1);
if (N_KIND((node = tmp_node)) == as_simple_name) {
if (in_label_set(node, label_id_set))
syntax_err(SPAN(node),"Duplicate label name");
else {
/* new_label_list = concatl(new_label_list,initlist(node)); */
label_id_set = tup_with(label_id_set, (char *)node);
}
new_label_list = tup_with(new_label_list, (char *)node);
}
else {
FORTUP(tmp_node2 = (Node), N_LIST(node), ft2);
label = tmp_node2;
if (in_label_set(label,label_id_set))
syntax_err(SPAN(label),"Duplicate label name");
else
label_id_set = tup_with(label_id_set, (char *)label);
ENDFORTUP(ft2);
}
ENDFORTUP(ft1)
/*
if (label_id_set != (struct two_pool *)0)